COMMENT ⊗   VALID 00003 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 -*-LISP-*-
C00007 00003
C00018 ENDMK
C⊗;
;;; -*-LISP-*-
;;; LET macro - pattern-decompositioning into variables which are lambda-bound,
;;; DESETQ macro - pattern-decompositioning into variables which are SETQ'd
;;; LET* macro - same as let, except the bindings happen sequentially with
;;;	the items in the "let" list, rather than in parallel.
;;; These will work in NIL too, and you can even have VECTORs as well as
;;;  LISTs in the pattern.
;;; They are defined using DEFMACRO, with the DEFMACRO-DISPLACE-CALL option
;;;   on, so that LET-expansions pay attention to MACCRO-EXPANSION-USE.
;;; Notice how cleverly the result of MUMBLIFY is decomposed into the
;;;   the variables A thru F.  The compilation of the SETQ sequence
;;;   will be quite optimal (leaving temproary results in registers
;;;   where permissible).  We do not use the pattern variables A thru F
;;;   for holding intermediate subexpressions, since they might be
;;;   declared as numerical variables at some higher level.


;;;      (LET ((((A (B C) () . D) E () . F) (MUMBLIFY))
;;;	       TEMP
;;;  	       (KEYNO '35)
;;;	       ANOTHER-TEMP)
;;;  	      (DECLARE (SPECIAL F KEYNO))
;;;  	      (COGITATE (LIST D E) A B C F))
;;;  
;;;  ==>
;;;
;;;  	((LAMBDA (G0005 TEMP KEYNO ANOTHER-TEMP F E D C B G0007 A G0006) 
;;;		 (DECLARE (SPECIAL F KEYNO))
;;;		 (SETQ G0006 (CAR G0005))
;;;		 (SETQ A (CAR G0006))
;;;		 (SETQ G0006 (CDR G0006))
;;;		 (SETQ G0007 (CAR G0006))
;;;		 (SETQ B (CAR G0007))
;;;		 (SETQ G0007 (CDR G0007))
;;;		 (SETQ C (CAR G0007))
;;;		 (SETQ G0006 (CDR G0006))
;;;		 (SETQ D (CDR G0006))
;;;		 (SETQ G0005 (CDR G0005))
;;;		 (SETQ E (CAR G0005))
;;;		 (SETQ G0005 (CDR G0005))
;;;		 (SETQ F (CDR G0005))
;;;		 (COGITATE (LIST D E) A B C F))
;;;	 (MUMBLIFY) () '35 () () () () () () () () ())

;;;      (DESETQ ((A (B C) NIL . D) E NIL . F)  (MUMBLIFY)
;;; 		 OLDBASES  (CONS IBASE BASE)
;;;      	 (IBASE . BASE)  NEWBASES)
;;;      
;;;  ==>
;;;   
;;;	((LAMBDA (G0008) 
;;;		 (SETQ G0009 (CAR G0008))
;;;		 (SETQ A (CAR G0009))
;;;		 (SETQ G0009 (CDR G0009))
;;;		 (SETQ G0010 (CAR G0009))
;;;		 (SETQ B (CAR G0010))
;;;		 (SETQ G0010 (CDR G0010))
;;;		 (SETQ C (CAR G0010))
;;;		 (SETQ G0009 (CDR G0009))
;;;		 (SETQ D (CDR G0009))
;;;		 (SETQ G0008 (CDR G0008))
;;;		 (SETQ E (CAR G0008))
;;;		 (SETQ G0008 (CDR G0008))
;;;		 (SETQ F (CDR G0008))
;;;		 (SETQ OLDBASES (CONS IBASE BASE))
;;;		 (SETQ IBASE (CAR NEWBASES))
;;;		 (SETQ BASE (CDR NEWBASES)))
;;; 	    (MUMBLIFY) )

;;; To see how LET* works, think of (LET ((A 1) (B (BUZZ))) ...) as producing
;;; ((LAMBDA (A B) ...) 1 (BUZZ)).  Then (LET* ((A 1) (B (BUZZ))) ...) produces
;;; ((LAMBDA (A) ((LAMBDA (B) ...) (BUZZ))) 1).  The difference will be seen
;;; when the computation (BUZZ) access the variable "A" freely.



(EVAL-WHEN (EVAL COMPILE)
  (AND (STATUS FEATURE MACLISP)
       (NOT (STATUS MACRO /#))
       (SETSYNTAX '/# 
		  'MACRO 
		  '(lambda ()
		    ((lambda (data)
			     (cond ((= data 40.) (macroexpand (read)))	;#(...)
				   ((= (setq data (tyi)) 44.)
				    (eval (read)))			;#,
				   ((= data 43.)
				    (or (mapcan '(lambda (x)		;#+(...)
						  (and (eval `(STATUS FEATURE ,x))
						       (list 'T)))
						(cond ((atom (setq data (read)))
						       (list data))
						      (data)))
					(read))
				    (read) )
				   ('t (and (caseq data 
					     ((77. 109.) 
					      (not (status feature MACLISP)))
					     ((81. 113.) 
					      (not (status feature LISPM)))
					     ((78. 110.) 
					      (not (status feature NIL)))
					     (T (break /#-LOSES!)))
					    (read))
				       (read) )))
		         (tyipeek)))))
)


(DECLARE (SPECIAL |.ds-tempvars/||)
	 (SETQ DEFMACRO-DISPLACE-CALL 'T 
	       DEFMACRO-FOR-COMPILING 'T 
	       DEFMACRO-CHECK-ARGS () ))


;;; Following function produces code to perform the decomposition
;;;  indicated by the pattern.

(DEFUN |.ds/|| (PAT VAR)
   (DECLARE (FIXNUM I))
   (AND PAT
	(LET ( (TYPAT (TYPEP PAT)) TMP )
	     (COND ((EQ 'SYMBOL TYPAT) (LIST `(SETQ ,pat ,var)))
#+(NIL) 	   ((EQ 'VECTOR TYPAT)
		    (LET ((LN (VECTOR-LENGTH PAT)))
			 (DECLARE (FIXNUM LN))
			 (DO ((I 0 (1+ I)) (ZZ) (TMP))
			     ((NOT (< I LN)) 
			      (CONS 
			       `(AND 
				 (OR (NOT (VECTORP ,var))
				     (NOT (= (VECTOR-LENGTH ,var) ,ln)))
				 (ERROR '|Not a proper-length VECTOR - DESETQ| 
					,var))
			       (NREVERSE ZZ)))
			     (COND ((NULL (SETQ TMP (VREF PAT) I)))
				   ((EQ (SETQ TYPAT (TYPEP TMP)) 'SYMBOL)
				    (PUSH `(SETQ ,tmp (VREF ,var ,i)) ZZ))
				   ((MEMQ TYPAT '(LIST VECTOR))
				    (COND ((|.anyvarsp/|| PAT)
					   (LET ((|.ds-tempvars/|| 
						  (CONS (GENSYM) |.ds-tempvars/||)))
						(PUSH `(SETQ ,(car |.ds-tempvars/||)
							      (VREF ,var ,i))
						      ZZ)
						(SETQ ZZ 
						      (NRECONC 
						       (|.ds/|| TMP (car |.ds-tempvars/||))
						       ZZ))))))))))
		   ((NOT (EQ 'LIST TYPAT)))
		   ((NOT (MEMQ (SETQ TYPAT (TYPEP (CAR PAT))) '(LIST VECTOR)))
		    (SETQ TMP (COND ((NULL (CDR PAT)) () )
				    ((MEMQ (SETQ TMP (TYPEP (CDR PAT)))
					   '(LIST VECTOR))
				     (CONS `(SETQ ,var (CDR ,var))
					   (|.ds/|| (CDR PAT) VAR)))
				    ((EQ 'SYMBOL TMP)
				     (CONS `(SETQ ,(cdr pat) (CDR ,var))
					   () ))))
		    (AND (EQ 'SYMBOL TYPAT)
			 (CAR PAT) 
			 (PUSH `(SETQ ,(car pat) (CAR ,var)) TMP))
		    TMP)
		   ((NOT (MEMQ (SETQ TYPAT (TYPEP (CDR PAT))) '(LIST VECTOR)))
		    (SETQ TMP (CONS `(SETQ ,var (CAR ,var)) 
				    (|.ds/|| (CAR PAT) VAR)))
		    (AND (EQ 'SYMBOL TYPAT)
			 (CDR PAT)
			 (PUSH `(SETQ ,(cdr pat) (CDR ,var)) TMP))
		    TMP)
		   ((NULL (|.anyvarsp/|| (CAR PAT))) 
		    (|.ds/|| (CONS (CAAR PAT) (CDR PAT))  VAR))
		   ((LET ( (|.ds-tempvars/|| (CONS (GENSYM) |.ds-tempvars/||)) 
			   (NEWVAR) (VAR-PRESET) )
			 (SETQ NEWVAR (CAR |.ds-tempvars/||))
			 (SETQ TMP (CONS `(SETQ ,newvar (CAR ,var))
					 (|.ds/|| (CAR PAT) NEWVAR)))
			 (AND (SETQ VAR-PRESET (|.ds/|| (CDR PAT) VAR))
			      (SETQ TMP (NCONC TMP 
					       (LIST `(SETQ ,var (CDR ,var))) 
					       VAR-PRESET)))
			 TMP))))))


;;; Following function finds the "rightmost" variable in a pattern, returning
;;;  () if there are no variables in the pattern.
;;; Argument "PAT" is guaranteed to be either a LIST or VECTOR

(DEFUN |.anyvarsp/|| (PAT)
   (AND PAT 
	(LET ( (TYPAT (TYPEP PAT)) )
	     (COND ((EQ 'SYMBOL TYPAT) PAT)
#+(NIL) 	   ((EQ 'VECTOR TYPAT)
		    (DO ( (I (1- (VECTOR-LENGTH PAT)) (1- I)) (TMP) )
			( (< I 0) () )
			(AND (SETQ TMP (|.anyvarsp/|| (VREF PAT I)))
			     (RETURN TMP))))
		   ((NOT (EQ TYPAT 'LIST)) () )
		   ((|.anyvarsp/|| (CDR PAT)))
		   ((|.anyvarsp/|| (CAR PAT)))))))


(DEFMACRO DESETQ  (&REST L)
   (DO (ZZ VAR GVAR |.ds-tempvars/||)
       ((NULL L) 
	 (SETQ ZZ (NREVERSE ZZ))
	 (COND ((NULL GVAR) (CONS 'PROGN ZZ))
	       ('T (SETQ VAR () )
		   (AND (EQ (CAAR ZZ) 'SETQ) 
			(EQ (CADAR ZZ) GVAR)
			(NULL (CDDDAR ZZ))
			(SETQ VAR (CADDAR ZZ) ZZ (CDR ZZ)))
		   `((LAMBDA (,gvar) ,@zz) ,var) )) )
     (COND ((ATOM (CAR L))
	    (AND (CAR L)
		 (SYMBOLP (CAR L)) 
		 (PUSH `(SETQ ,(car l) ,(cadr l)) ZZ)))
	   ((COND ((ATOM (CADR L))
		   (AND (CADR L) 
			(SYMBOLP (CADR L))
			(SETQ VAR (CADR L))))
		  ('T (AND (NULL GVAR) (SETQ GVAR (GENSYM)))
		      (SETQ VAR GVAR)
		      (PUSH `(SETQ ,var ,(cadr l))  ZZ)
		      'T))
	    (SETQ ZZ (NRECONC (|.ds/|| (CAR L) VAR) ZZ))))
     (SETQ L (CDDR L))))


(DEFMACRO LET* (LETL &REST LMBODY &AUX DECLP)
    (COND ((ATOM LETL) `(LET ,letl ,lmbody))
	  ('T (COND ((AND (NOT (ATOM (CAR LMBODY))) 
			  (EQ (CAAR LMBODY) 'DECLARE))
		     (SETQ DECLP (LIST (CAR LMBODY)))
		     (SETQ LMBODY (CDR LMBODY))))
	      `(LET (,(car letl)) 
		    ,@declp 
		    ,(|iter-let/|| (cdr letl) (cons 'progn lmbody))))))


(DEFUN |iter-let/|| (LETL LMBODY)
  (COND ((NULL LETL) LMBODY)
	(`(LET (,(car letl)) ,(|iter-let/|| (cdr letl) lmbody)))))


;;; WAIT! You loser, don't move this function.  If must occur after all its
;;;   usages, so that the previous LET will be active during compilation.


(DEFMACRO LET  L 
  ((LAMBDA (OK-FL LMBODY DECLP VARS VALS GVAR XTRAVARS XTRAVALS 
		  PATFL LL |.ds-tempvars/||) 
	   (COND ((AND (NOT (ATOM (CAR LMBODY))) 
		       (EQ (CAAR LMBODY) 'DECLARE))
		  (SETQ DECLP (LIST (CAR LMBODY)))
		  (SETQ LMBODY (CDR LMBODY))))
	   (MAPC '(LAMBDA (IL)
		   (COND ((ATOM IL)
			  (COND ((AND IL (SYMBOLP IL))
				 (PUSH IL VARS) (PUSH () VALS))
				((SETQ OK-FL () ))))
			 ((CDDR IL) (SETQ OK-FL () ))
			 ((NOT (ATOM (CAR IL)))
			  (PUSH (CADR IL) VALS)
			  (SETQ LL (|.ds/|| (CAR IL) (SETQ GVAR (GENSYM))))
			  (COND ((NULL LL) (PUSH () VARS))
				(T (PUSH GVAR VARS)
				   (MAPC '(LAMBDA (Z) 
						  (COND ((AND (NOT (EQ (CADR Z) GVAR)) 
							      (NOT (MEMQ (CADR Z) XTRAVARS)))
							 (PUSH (CADR Z) XTRAVARS)
							 (PUSH () XTRAVALS))))
					 LL)))
			  (SETQ PATFL (NCONC LL PATFL)))
			 ('T (PUSH (CAR IL) VARS) (PUSH (CADR IL) VALS))))
		 (CAR L))
	   (AND (NOT OK-FL)
		(ERROR '|Bad variable list in LET macro usage| (CAR L)))
	   `((LAMBDA ,(nreconc vars xtravars)
		      ,@declp 
		      ,@(nconc patfl lmbody))
	     ,@(nreconc vals xtravals)))
      'T (CDR L) () () () () () () () () () ))